Collection of Tools & Utilities/Collection of Tools and Utilities.iso/pascal/xlibpas2.zip/XGIF2.PAS

Pascal/Delphi Source File | 1994-06-12 | 18KB | 756 lines

unit XGIF2;
{ ************************************************
  **    GIF Decoding and Encoding procedures    **
  **        for Borland/Turbo Pascal 7.0        **
  **                                            **
  **     Written by Tristan Tarrant, 1994       **
  **                                            **
  **        ( Supports GIF87a/GIF89a )          **
  ************************************************ }

interface

uses
    Dos;

const
    { Error constants used in GIF decoder }
    GoodRead      = 0;
    BadFile       = 1;
    BadRead       = 2;
    UnexpectedEOF = 3;
    BadCode       = 4;
    BadFirstCode  = 5;
    NoFile        = 6;
    BadSymbolSize = 7;
    NoCode        = -1;
    Gif87a        = 0;
    Gif89a        = 1;

    { These values will be masked with the codes output from the
        decoder to remove spurious bits }
    CodeMask : array[1..13] of word =
        ( $0000,
            $0001, $0003,
            $0007, $000F,
            $001F, $003F,
            $007F, $00FF,
            $01FF, $03FF,
            $07FF, $0FFF );

Type
    GifLineProcType = procedure( Var pixels; line, width : integer );
    GifPixelProcType = function : integer;
    TByteArray = Array[0..0] of byte;
    TIntArray = Array[0..0] of integer;

Var
    { Pointers to custom procedures to deal with lines. GifOutLineProc
      is called with three parameters : an untyped var, containing
      the uncompressed data, and two integer values, containing the
      line number and the width of the line.
      GifInPixelProc should instead return a pixels value, -1 if at the
      end of the data. }

    GifOutLineProc : GifLineProcType;
    GifInPixelProc : GifPixelProcType;
    GifPalette : array[0..767] of byte;



function LoadGif( f : string ) : integer;
function SaveGif( f : string; width, depth, bits : integer; var palette ) : integer;
function GifError( ErrorCode : integer ) : string;

Implementation

type
    GifHeader =
        record
            sig : array[1..6] of char;
            screenwidth, screendepth : word;
            flags, background, aspect : byte;
        end;

    ImageBlock =
        record
            left, top, width, depth : word;
            flags : byte;
        end;

    FileInfo =
        record
            width, depth, bits,
            flags, background : integer;
            palette : array[1..768] of byte;
        end;

    ControlBlock =
        record
            blocksize, flags : byte;
            delay : word;
            transparentcolour, terminator : byte;
        end;

    PlainText =
        record
            blocksize : byte;
            left, top, gridwidth, gridheight : word;
            cellwidth, cellheight, forecolour, backcolour : byte;
        end;

    Application =
        record
            blocksize : byte;
            applstring : array[1..8] of char;
            authentication : array[1..3] of char;
        end;


const
    TableSize = 5003;
    LargestCode = 4095;

function UnpackImage( var F : File; bits : integer; Var fi : FileInfo ) : integer;
var
    bits2, codesize, codesize2, nextcode, thiscode,
    oldtoken, currentcode, oldcode, bitsleft, blocksize,
    line, pass, byt, p, q, u : integer;
    b : array[0..255] of byte;
    linebuffer, firstcodestack, lastcodestack : ^TByteArray;
    codestack : ^TIntArray;
const
    wordmasktable : array[0..15] of word =
        ( $0000, $0001, $0003, $0007, $000F, $001F,
            $003F, $007F, $00FF, $01FF, $03FF, $07FF,
            $0FFF, $1FFF, $3FFF, $7FFF );
    inctable : array[0..4] of integer = ( 8, 8, 4, 2, 0 );
    starttable : array[0..4] of integer = ( 0, 4, 2, 1, 0 );
begin
    pass := 0;
    line := 0;
    byt := 0;
    p := 0;
    q := 0;
    blocksize := 0;
    fillchar( b, 256, 0 );
    bitsleft := 8;
    if ( bits < 2 ) or ( bits > 8 ) then
    begin
        UnpackImage := BadSymbolSize;
        exit;
    end;
    bits2 := 1 shl bits;
    nextcode := bits2 + 2;
    codesize := bits + 1;
    codesize2 := 1 shl codesize;
    oldcode := NoCode;
    oldtoken := NoCode;
    getmem( firstcodestack, 4096 );
    getmem( lastcodestack, 4096 );
    getmem( codestack, 8192 );
    getmem( linebuffer, fi.width );
    while true do
    begin
        if bitsleft = 8 then
        begin
            inc(p);
            if p>=q then
            begin
                blocksize := 0;
                blockread( F, blocksize, 1);
                if blocksize>0 then
                begin
                    p:=0;
                    blockread( F, b, blocksize, q );
                    if q<>blocksize then
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end else
                begin
                    freemem( firstcodestack, 4096 );
                    freemem( lastcodestack, 4096 );
                    freemem( codestack, 8192 );
                    freemem( linebuffer, fi.width );
                    UnpackImage := UnexpectedEOF;
                    exit;
                end;
            end;
            bitsleft := 0;
        end;
        thiscode := b[p];
        currentcode := codesize + bitsleft;
        if currentcode <=8 then
        begin
            b[p] := b[p] shr codesize;
            bitsleft := currentcode;
        end else
        begin
            inc(p);
            if p>=q then
            begin
                blocksize := 0;
                blockread( F, blocksize, 1);
                if blocksize>0 then
                begin
                    p:=0;
                    blockread( F, b, blocksize, q );
                    if q<>blocksize then
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end else
                begin
                    freemem( firstcodestack, 4096 );
                    freemem( lastcodestack, 4096 );
                    freemem( codestack, 8192 );
                    freemem( linebuffer, fi.width );
                    UnpackImage := UnexpectedEOF;
                    exit;
                end;
            end;
            thiscode := thiscode or ( b[p] shl (8-bitsleft) );
            if currentcode <= 16 then
            begin
                bitsleft := currentcode - 8;
                b[p] := b[p] shr bitsleft;
            end else
            begin
                inc(p);
                if p>=q then
                begin
                    blocksize := 0;
                    blockread( F, blocksize, 1);
                    if blocksize>0 then
                    begin
                        p:=0;
                        blockread( F, b, blocksize, q );
                        if q<>blocksize then
                        begin
                            freemem( firstcodestack, 4096 );
                            freemem( lastcodestack, 4096 );
                            freemem( codestack, 8192 );
                            freemem( linebuffer, fi.width );
                            UnpackImage := UnexpectedEOF;
                            exit;
                        end;
                    end else
                    begin
                        freemem( firstcodestack, 4096 );
                        freemem( lastcodestack, 4096 );
                        freemem( codestack, 8192 );
                        freemem( linebuffer, fi.width );
                        UnpackImage := UnexpectedEOF;
                        exit;
                    end;
                end;
                thiscode := thiscode or ( b[p] shl (16-bitsleft) );
                bitsleft := currentcode - 16;
                b[p] := b[p] shr bitsleft;
            end;
        end;
        thiscode := thiscode and wordmasktable[codesize];
        currentcode := thiscode;
        if thiscode = bits2+1 then break;
        if thiscode > nextcode then
        begin
            freemem( firstcodestack, 4096 );
            freemem( lastcodestack, 4096 );
            freemem( codestack, 8192 );
            freemem( linebuffer, fi.width );
            UnpackImage := BadCode;
            exit;
        end;
        if thiscode = bits2 then
        begin
            nextcode := bits2+2;
            codesize := bits + 1;
            codesize2 := 1 shl codesize;
            oldtoken := NoCode;
            OldCode := NoCode;
            continue;
        end;
        u := 0;
        if thiscode = nextcode then
        begin
            if oldcode = NoCode then
            begin
                freemem( firstcodestack, 4096 );
                freemem( lastcodestack, 4096 );
                freemem( codestack, 8192 );
                freemem( linebuffer, fi.width );
                UnpackImage := BadFirstCode;
                exit;
            end;
            firstcodestack^[u] := oldtoken;
            inc( u );
            thiscode := oldcode;
        end;
        while thiscode >= bits2 do
        begin
            firstcodestack^[u] := lastcodestack^[thiscode];
            inc( u );
            thiscode := codestack^[thiscode];
        end;
        oldtoken := thiscode;
        while true do
        begin
            linebuffer^[byt] := thiscode;
            inc( byt );
            if byt >= fi.width then
            begin
                GifOutLineProc( linebuffer^, line, fi.width );
                byt := 0;
                if fi.flags and $40 = $40 then
                begin
                    line := line + inctable[pass];
                    if line >= fi.depth then
                    begin
                        inc(pass);
                        line := starttable[pass];
                    end;
                end else inc(line);
            end;
            if u <= 0 then break;
            dec( u );
            thiscode := firstcodestack^[u];
        end;
        if (nextcode < 4096) and (oldcode <> NoCode) then
        begin
            codestack^[nextcode] := oldcode;
            lastcodestack^[nextcode] := oldtoken;
            in